home *** CD-ROM | disk | FTP | other *** search
/ Night Owl 6 / Night Owl's Shareware - PDSI-006 - Night Owl Corp (1990).iso / 016a / gofer221.zip / COMPILER.C < prev    next >
C/C++ Source or Header  |  1991-11-20  |  42KB  |  1,400 lines
  1. /* --------------------------------------------------------------------------
  2.  * compiler.c:    Copyright (c) Mark P Jones 1991.   All rights reserved.
  3.  *        See goferite.h for details and conditions of use etc...
  4.  *        Gofer version 2.21 November 1991
  5.  *
  6.  *        Last updated 01/11/91 mpj
  7.  *
  8.  * This is the Gofer compiler, handling translation of typechecked code to
  9.  * `kernel' language, elimination of pattern matching and translation to
  10.  * super combinators (lambda lifting).
  11.  * ------------------------------------------------------------------------*/
  12.  
  13. #include "prelude.h"
  14. #include "storage.h"
  15. #include "connect.h"
  16.  
  17. Bool useConformality = TRUE;           /* TRUE => check pat-bind conform'ty*/
  18. Addr inputCode;                /* Address of compiled code for expr*/
  19.  
  20. /* --------------------------------------------------------------------------
  21.  * Local function prototypes:
  22.  * ------------------------------------------------------------------------*/
  23.  
  24. static Cell local translate        Args((Cell));
  25. static Void local transPair        Args((Pair));
  26. static Void local transTriple        Args((Triple));
  27. static Void local transAlt        Args((Cell));
  28. static Void local transCase        Args((Cell));
  29. static List local transBinds        Args((List));
  30. static Cell local transRhs        Args((Cell));
  31. static Cell local mkConsList        Args((List));
  32. static Cell local expandLetrec        Args((Cell));
  33.  
  34. static Cell local transComp        Args((Cell,List,Cell));
  35.  
  36. static Bool local refutable        Args((Cell));
  37. static Cell local refutePat        Args((Cell));
  38. static List local remPat        Args((Cell,Cell,List));
  39. static List local remPat1        Args((Cell,Cell,List));
  40.  
  41. static Cell local pmcTerm        Args((Int,List,Cell));
  42. static Cell local pmcAp            Args((Int,List,Pair));
  43. static Cell local pmcPair        Args((Int,List,Pair));
  44. static Cell local pmcTriple        Args((Int,List,Triple));
  45. static Cell local pmcVar        Args((List,Text));
  46. static Void local pmcLetrec        Args((Int,List,Pair));
  47. static Cell local pmcVarDef        Args((Int,List,List));
  48. static Void local pmcFunDef        Args((Int,List,Triple));
  49.  
  50. static Cell local match         Args((Int,List,List));
  51. static Void local tidyHdPat        Args((Offset,Cell));
  52. static Cell local hdDiscr        Args((List));
  53. static Int  local discrKind        Args((Cell));
  54.  
  55. static Cell local matchVar        Args((Int,List,List,Cell));
  56.  
  57. static Cell local matchCon        Args((Int,List,List,Cell));
  58. static List local addConTable        Args((Cell,Cell,List));
  59. static Cell local makeCases        Args((Int,List,List));
  60.  
  61. static Cell local matchInt        Args((Int,List,List,Cell));
  62.  
  63. static List local addOffsets        Args((Int,Int,List));
  64. static Cell local mkSwitch        Args((List,Pair));
  65. static Cell local joinSw        Args((Int,List));
  66. static Bool local canFail        Args((Cell));
  67.  
  68. static Cell local lift            Args((Int,List,Cell));
  69. static Void local liftAp        Args((Int,List,Pair));
  70. static Void local liftPair        Args((Int,List,Pair));
  71. static Void local liftTriple        Args((Int,List,Triple));
  72. static Void local liftAlt        Args((Int,List,Cell));
  73. static Cell local liftVar        Args((List,Cell));
  74. static Cell local liftLetrec        Args((Int,List,Cell));
  75. static Void local liftFundef        Args((Int,List,Triple));
  76. static Void local solve         Args((List));
  77.  
  78. static Cell local preComp        Args((Cell));
  79. static Cell local preCompPair        Args((Pair));
  80. static Cell local preCompTriple     Args((Triple));
  81. static Void local preCompCase        Args((Pair));
  82. static Cell local preCompOffset     Args((Int));
  83.  
  84. static Void local compileGlobalFunction Args((Pair));
  85. static Void local compileMemberFunction Args((Name));
  86. static Void local newGlobalFunction    Args((Name,Int,List,Int,Cell));
  87.  
  88. /* --------------------------------------------------------------------------
  89.  * Transformation: Convert input expressions into a less complex language
  90.  *           of terms using only LETREC, AP, constants and vars.
  91.  *           Also remove pattern definitions on lhs of eqns.
  92.  * ------------------------------------------------------------------------*/
  93.  
  94. static Cell local translate(e)           /* Translate expression:        */
  95. Cell e; {
  96.     switch (whatIs(e)) {
  97.     case LETREC    : snd(snd(e)) = translate(snd(snd(e)));
  98.               return expandLetrec(e);
  99.  
  100.     case COND    : transTriple(snd(e));
  101.               break;
  102.  
  103.     case AP     : transPair(e);
  104.               break;
  105.  
  106.     case UNIT    :
  107.     case TUPLE    :
  108.     case NAME    :
  109.     case SELECT    :
  110.     case VAROPCELL    :
  111.     case VARIDCELL    :
  112.     case DICTVAR    :
  113.     case DICTCELL    :
  114.     case INTCELL    :
  115.     case FLOATCELL  :
  116.     case STRCELL    :
  117.     case CHARCELL    : break;
  118.  
  119.     case FINLIST    : mapOver(translate,snd(e));
  120.               return mkConsList(snd(e));
  121.  
  122.     case LISTCOMP    : return transComp(translate(fst(snd(e))),
  123.                        snd(snd(e)),
  124.                        nameNil);
  125.  
  126.     case ESIGN    : return translate(fst(snd(e)));
  127.  
  128.     case CASE    : {   Cell nv = inventVar();
  129.                   mapProc(transCase,snd(snd(e)));
  130.                   return ap(LETREC,
  131.                     pair(singleton(pair(nv,snd(snd(e)))),
  132.                          ap(nv,translate(fst(snd(e))))));
  133.               }
  134.  
  135.     case LAMBDA    : {   Cell nv = inventVar();
  136.                   transAlt(snd(e));
  137.                   return ap(LETREC,
  138.                     pair(singleton(pair(
  139.                             nv,
  140.                             singleton(snd(e)))),
  141.                          nv));
  142.               }
  143.  
  144.     default     : internal("translate");
  145.     }
  146.     return e;
  147. }
  148.  
  149. static Void local transPair(pr)        /* Translate each component in a    */
  150. Pair pr; {                   /* pair of expressions.           */
  151.     fst(pr) = translate(fst(pr));
  152.     snd(pr) = translate(snd(pr));
  153. }
  154.  
  155. static Void local transTriple(tr)      /* Translate each component in a    */
  156. Triple tr; {                   /* triple of expressions.       */
  157.     fst3(tr) = translate(fst3(tr));
  158.     snd3(tr) = translate(snd3(tr));
  159.     thd3(tr) = translate(thd3(tr));
  160. }
  161.  
  162. static Void local transAlt(e)           /* Translate alt:           */
  163. Cell e; {                   /* ([Pat], Rhs) ==> ([Pat], Rhs')   */
  164.     snd(e) = transRhs(snd(e));
  165. }
  166.  
  167. static Void local transCase(c)           /* Translate case:           */
  168. Cell c; {                   /* (Pat, Rhs) ==> ([Pat], Rhs')       */
  169.     fst(c) = singleton(fst(c));
  170.     snd(c) = transRhs(snd(c));
  171. }
  172.  
  173. static List local transBinds(bs)       /* Translate list of bindings:       */
  174. List bs; {                   /* eliminating pattern matching on  */
  175.     List newBinds;               /* lhs of bindings.           */
  176.  
  177.     for (newBinds=NIL; nonNull(bs); bs=tl(bs)) {
  178.     if (isVar(fst(hd(bs)))) {
  179.         mapProc(transAlt,snd(hd(bs)));
  180.         newBinds = cons(hd(bs),newBinds);
  181.     }
  182.     else
  183.         newBinds = remPat(fst(snd(hd(bs))),
  184.                   snd(snd(hd(bs)))=transRhs(snd(snd(hd(bs)))),
  185.                   newBinds);
  186.     }
  187.  
  188.     return newBinds;
  189. }
  190.  
  191. static Cell local transRhs(rhs)        /* Translate rhs: removing line nos */
  192. Cell rhs; {
  193.     switch (whatIs(rhs)) {
  194.     case LETREC  : snd(snd(rhs)) = transRhs(snd(snd(rhs)));
  195.                return expandLetrec(rhs);
  196.  
  197.     case GUARDED : mapOver(snd,snd(rhs));        /* discard line number */
  198.                mapProc(transPair,snd(rhs));
  199.                return rhs;
  200.  
  201.     default      : return translate(snd(rhs));  /* discard line number */
  202.     }
  203. }
  204.  
  205. static Cell local mkConsList(es)       /* Construct expression for list es */
  206. List es; {                   /* using nameNil and nameCons       */
  207.     if (isNull(es))
  208.     return nameNil;
  209.     else
  210.     return ap(ap(nameCons,hd(es)),mkConsList(tl(es)));
  211. }
  212.  
  213. static Cell local expandLetrec(root)   /* translate LETREC with list of    */
  214. Cell root; {                   /* groups of bindings (from depend. */
  215.     Cell e   = snd(snd(root));           /* analysis) to use nested LETRECs  */
  216.     List bss = fst(snd(root));
  217.     Cell temp;
  218.  
  219.     if (isNull(bss))               /* should never happen, but just in */
  220.     return e;               /* case:  LETREC [] IN e  ==>  e    */
  221.  
  222.     mapOver(transBinds,bss);           /* translate each group of bindings */
  223.  
  224.     for (temp=root; nonNull(tl(bss)); bss=tl(bss)) {
  225.     fst(snd(temp)) = hd(bss);
  226.     snd(snd(temp)) = ap(LETREC,pair(NIL,e));
  227.     temp           = snd(snd(temp));
  228.     }
  229.     fst(snd(temp)) = hd(bss);
  230.  
  231.     return root;
  232. }
  233.  
  234. /* --------------------------------------------------------------------------
  235.  * Transformation of list comprehensions is based on the description in
  236.  * `The Implementation of Functional Programming Languages':
  237.  *
  238.  * [ e | qs ] ++ L          => transComp e qs []
  239.  * transComp e []        l => e : l
  240.  * transComp e ((p<-xs):qs) l => LETREC _h []       = l
  241.  *                    _h (p:_xs) = transComp e qs (_h _xs)
  242.  *                    _h (_:_xs) = _h _xs --if p refutable.
  243.  *                 IN _h xs
  244.  * transComp e (b:qs)        l => if b then transComp e qs l else l
  245.  * transComp e ((p=e1):qs)  l => LETREC p = e1 IN transComp e qs l
  246.  * ------------------------------------------------------------------------*/
  247.  
  248. static Cell local transComp(e,qs,l)    /* Translate [e | qs] ++ l       */
  249. Cell e;
  250. List qs;
  251. Cell l; {
  252.     if (nonNull(qs)) {
  253.     Cell q     = hd(qs);
  254.     Cell qs1 = tl(qs);
  255.  
  256.     switch (fst(q)) {
  257.         case FROMQUAL : {    Cell ld    = NIL;
  258.                 Cell hVar  = inventVar();
  259.                 Cell xsVar = inventVar();
  260.  
  261.                 if (refutable(fst(snd(q))))
  262.                     ld = cons(pair(singleton(
  263.                             ap(ap(nameCons,
  264.                               WILDCARD),
  265.                               xsVar)),
  266.                            ap(hVar,xsVar)),
  267.                           ld);
  268.  
  269.                 ld = cons(pair(singleton(
  270.                         ap(ap(nameCons,
  271.                               fst(snd(q))),
  272.                               xsVar)),
  273.                            transComp(e,
  274.                              qs1,
  275.                              ap(hVar,xsVar))),
  276.                       ld);
  277.                 ld = cons(pair(singleton(nameNil),
  278.                            l),
  279.                       ld);
  280.  
  281.                 return ap(LETREC,
  282.                       pair(singleton(pair(hVar,
  283.                                   ld)),
  284.                            ap(hVar,
  285.                           translate(snd(snd(q))))));
  286.                 }
  287.  
  288.         case QWHERE   : return ap(LETREC,
  289.                       pair(remPat(fst(snd(q)),
  290.                           translate(snd(snd(q))),
  291.                           NIL),
  292.                        transComp(e,qs1,l)));
  293.  
  294.         case BOOLQUAL : return ap(COND,
  295.                       triple(translate(snd(q)),
  296.                          transComp(e,qs1,l),
  297.                          l));
  298.     }
  299.     }
  300.  
  301.     return ap(ap(nameCons,e),l);
  302. }
  303.  
  304. /* --------------------------------------------------------------------------
  305.  * Elimination of pattern bindings:
  306.  *
  307.  * The following code adopts the definition of irrefutable patterns as given
  308.  * in the Haskell report in which only variables, wildcards and ~pat patterns
  309.  * are irrefutable.  Note that the definition in Peyton Jones also includes
  310.  * product constructor functions (e.g. tuples) as irrefutable patterns.
  311.  * ------------------------------------------------------------------------*/
  312.  
  313. static Bool local refutable(pat)  /* is pattern refutable (do we need to   */
  314. Cell pat; {              /* to use a conformality check?)       */
  315.     Cell c = getHead(pat);
  316.  
  317.     switch (whatIs(c)) {
  318.     case ASPAT     : return refutable(snd(snd(pat)));
  319.  
  320.     case LAZYPAT   :
  321.     case VAROPCELL :
  322.     case VARIDCELL :
  323.     case DICTVAR   :
  324.     case WILDCARD  : return FALSE;
  325.  
  326.     default        : return TRUE;
  327.     }
  328. }
  329.  
  330. static Cell local refutePat(pat)  /* find pattern to refute in conformality*/
  331. Cell pat; {              /* test with pat.               */
  332.                   /* e.g. refPat  (x,y) == (_,_)       */
  333.                   /*      refPat ~(x,y) == _      etc..    */
  334.  
  335.     switch (whatIs(pat)) {
  336.     case ASPAT     : return refutePat(snd(snd(pat)));
  337.  
  338.     case FINLIST   : {   Cell ys = snd(pat);
  339.                  Cell xs = NIL;
  340.                  for (; nonNull(ys); ys=tl(ys))
  341.                  xs = ap(ap(nameCons,refutePat(hd(ys))),xs);
  342.                  return revOnto(xs,nameNil);
  343.              }
  344.  
  345.     case VAROPCELL :
  346.     case VARIDCELL :
  347.     case DICTVAR   :
  348.     case WILDCARD  :
  349.     case LAZYPAT   : return WILDCARD;
  350.  
  351.     case INTCELL   :
  352.         case FLOATCELL :
  353.     case STRCELL   :
  354.     case CHARCELL  :
  355.     case ADDPAT    :
  356.     case MULPAT    :
  357.     case UNIT      :
  358.     case TUPLE     :
  359.     case NAME      : return pat;
  360.  
  361.     case AP        : return ap(refutePat(fun(pat)),refutePat(arg(pat)));
  362.  
  363.     default        : internal("refutePat");
  364.              return NIL; /*NOTREACHED*/
  365.     }
  366. }
  367.  
  368. #define addEqn(v,val,lds)  cons(pair(v,singleton(pair(NIL,val))),lds)
  369.  
  370. static List local remPat(pat,expr,lds)
  371. Cell pat;              /* Produce list of definitions for eqn   */
  372. Cell expr;              /* pat = expr, including a conformality  */
  373. List lds; {              /* check if required.            */
  374.  
  375.     /* Conformality test (if required):
  376.      *     pat = expr  ==>    nv = LETREC confCheck nv@pat = nv
  377.      *                 IN confCheck expr
  378.      *                remPat1(pat,nv,.....);
  379.      */
  380.  
  381.     if (useConformality && refutable(pat)) {
  382.     Cell confVar = inventVar();
  383.     Cell nv      = inventVar();
  384.     Cell locfun  = pair(confVar,         /* confVar [([nv@refPat],nv)] */
  385.                 singleton(pair(singleton(ap(ASPAT,
  386.                             pair(nv,
  387.                                  refutePat(pat)))),
  388.                        nv)));
  389.  
  390.     lds = addEqn(nv,                /* nv =        */
  391.              ap(LETREC,pair(singleton(locfun),    /* LETREC [locfun] */
  392.                     ap(confVar,expr))), /* IN confVar expr */
  393.              lds);
  394.  
  395.     return remPat1(pat,nv,lds);
  396.     }
  397.  
  398.     return remPat1(pat,expr,lds);
  399. }
  400.  
  401. static List local remPat1(pat,expr,lds)
  402. Cell pat;              /* Add definitions for: pat = expr to    */
  403. Cell expr;              /* list of local definitions in lds.       */
  404. List lds; {
  405.     Cell c;
  406.  
  407.     switch (whatIs(c=getHead(pat))) {
  408.     case WILDCARD  :
  409.     case UNIT      :
  410.     case INTCELL   :
  411.         case FLOATCELL :
  412.     case STRCELL   :
  413.     case CHARCELL  : break;
  414.  
  415.     case ASPAT     : return remPat1(snd(snd(pat)),       /* v@pat = expr */
  416.                     expr,
  417.                     addEqn(fst(snd(pat)),expr,lds));
  418.  
  419.     case LAZYPAT   : {   Cell nv;
  420.  
  421.                  if (isVar(expr) || isName(expr))
  422.                  nv  = expr;
  423.                  else {
  424.                  nv  = inventVar();
  425.                  lds = addEqn(nv,expr,lds);
  426.                  }
  427.  
  428.                  return remPat(snd(pat),nv,lds);
  429.              }
  430.  
  431.     case ADDPAT    : return addEqn(snd(pat),       /* n + k = expr */
  432.                        ap(ap(nameMinus,expr),
  433.                       mkInt(intValOf(fst(pat)))),
  434.                        lds);
  435.  
  436.     case MULPAT    : return addEqn(snd(pat),       /* c * n = expr */
  437.                        ap(ap(nameDivide,expr),
  438.                       mkInt(intValOf(fst(pat)))),
  439.                        lds);
  440.  
  441.     case FINLIST   : return remPat1(mkConsList(snd(pat)),expr,lds);
  442.  
  443.     case DICTVAR   : /* shouldn't really occur */
  444.     case VARIDCELL :
  445.     case VAROPCELL : return addEqn(pat,expr,lds);
  446.  
  447.     case TUPLE     :
  448.     case NAME      : {   List ps = getArgs(pat);
  449.                  Cell nv, sel;
  450.                  Int  i;
  451.  
  452.                  if (isVar(expr) || isName(expr))
  453.                  nv  = expr;
  454.                  else {
  455.                  nv  = inventVar();
  456.                  lds = addEqn(nv,expr,lds);
  457.                  }
  458.  
  459.                  sel = ap(ap(nameSel,c),nv);
  460.                  for (i=1; nonNull(ps); ++i, ps=tl(ps))
  461.                  lds = remPat1(hd(ps),ap(sel,mkInt(i)),lds);
  462.              }
  463.              break;
  464.  
  465.     default        : internal("error in remPat1");
  466.              break;
  467.     }
  468.     return lds;
  469. }
  470.  
  471. /* --------------------------------------------------------------------------
  472.  * Eliminate pattern matching in function definitions -- pattern matching
  473.  * compiler:
  474.  *
  475.  * Based on Wadler's algorithms described in `Implementation of functional
  476.  * programming languages'.
  477.  *
  478.  * During the translation, in preparation for later stages of compilation,
  479.  * all local and bound variables are replaced by suitable offsets, and
  480.  * locally defined function symbols are given new names (which will
  481.  * eventually be their names when lifted to make top level definitions).
  482.  * ------------------------------------------------------------------------*/
  483.  
  484. static Offset freeBegin; /* only variables with offset <= freeBegin are of */
  485. static List   freeVars;  /* interest as `free' variables           */
  486. static List   freeFuns;  /* List of `free' local functions           */
  487.  
  488. static Cell local pmcTerm(co,sc,e)     /* apply pattern matching compiler  */
  489. Int  co;                   /* co = current offset           */
  490. List sc;                   /* sc = scope               */
  491. Cell e;  {                   /* e  = expr to transform       */
  492.     switch (whatIs(e)) {
  493.     case GUARDED  : map2Over(pmcPair,co,sc,snd(e));
  494.             break;
  495.  
  496.     case LETREC   : pmcLetrec(co,sc,snd(e));
  497.             break;
  498.  
  499.     case VARIDCELL:
  500.     case VAROPCELL:
  501.     case DICTVAR  : return pmcVar(sc,textOf(e));
  502.  
  503.     case COND     : return ap(COND,pmcTriple(co,sc,snd(e)));
  504.  
  505.     case AP       : return pmcAp(co,sc,e);
  506.  
  507.     case UNIT     :
  508.     case TUPLE    :
  509.     case NAME     :
  510.     case SELECT   :
  511.     case DICTCELL :
  512.     case CHARCELL :
  513.     case INTCELL  :
  514.         case FLOATCELL:
  515.     case STRCELL  : break;
  516.  
  517.     default       : internal("pmcTerm");
  518.             break;
  519.     }
  520.     return e;
  521. }
  522.  
  523. static Cell local pmcAp(co,sc,pr)      /* apply pattern matching compiler  */
  524. Int  co;                   /* to application               */
  525. List sc;
  526. Pair pr; {
  527.     return pair(pmcTerm(co+1,sc,fst(pr)),
  528.         pmcTerm(co,sc,snd(pr)));
  529. }
  530.  
  531. static Cell local pmcPair(co,sc,pr)    /* apply pattern matching compiler  */
  532. Int  co;                   /* to a pair of exprs           */
  533. List sc;
  534. Pair pr; {
  535.     return pair(pmcTerm(co,sc,fst(pr)),
  536.         pmcTerm(co,sc,snd(pr)));
  537. }
  538.  
  539. static Cell local pmcTriple(co,sc,tr)  /* apply pattern matching compiler  */
  540. Int    co;                   /* to a triple of exprs           */
  541. List   sc;
  542. Triple tr; {
  543.     return triple(pmcTerm(co,sc,fst3(tr)),
  544.           pmcTerm(co,sc,snd3(tr)),
  545.           pmcTerm(co,sc,thd3(tr)));
  546. }
  547.  
  548. static Cell local pmcVar(sc,t)           /* find translation of variable       */
  549. List sc;                   /* in current scope           */
  550. Text t; {
  551.     List xs;
  552.     Name n;
  553.  
  554.     for (xs=sc; nonNull(xs); xs=tl(xs)) {
  555.     Cell x = hd(xs);
  556.     if (t==textOf(fst(x)))
  557.         if (isOffset(snd(x))) {             /* local variable ... */
  558.         if (snd(x)<=freeBegin && !cellIsMember(snd(x),freeVars))
  559.             freeVars = cons(snd(x),freeVars);
  560.         return snd(x);
  561.         }
  562.         else {                     /* local function ... */
  563.         if (!cellIsMember(snd(x),freeFuns))
  564.             freeFuns = cons(snd(x),freeFuns);
  565.         return fst3(snd(x));
  566.         }
  567.     }
  568.  
  569.     if (isNull(n=findName(t)))           /* Lookup global name - the only way*/
  570.     n = newName(t);            /* this (should be able to happen)  */
  571.                        /* is with new global var introduced*/
  572.                        /* after type check; e.g. remPat1   */
  573.     return n;
  574. }
  575.  
  576. static Void local pmcLetrec(co,sc,e)   /* apply pattern matching compiler  */
  577. Int  co;                   /* to LETREC, splitting decls into  */
  578. List sc;                   /* two sections               */
  579. Pair e; {
  580.     List fs = NIL;               /* local function definitions       */
  581.     List vs = NIL;               /* local variable definitions       */
  582.     List ds;
  583.  
  584.     for (ds=fst(e); nonNull(ds); ds=tl(ds)) {        /* Split decls into two */
  585.     Cell v       = fst(hd(ds));
  586.     Int  arity = length(fst(hd(snd(hd(ds)))));
  587.  
  588.     if (arity==0) {                /* Variable declaration */
  589.         vs = cons(snd(hd(ds)),vs);
  590.         sc = cons(pair(v,mkOffset(++co)),sc);
  591.     }
  592.     else {                       /* Function declaration */
  593.         fs = cons(triple(inventVar(),mkInt(arity),snd(hd(ds))),fs);
  594.         sc = cons(pair(v,hd(fs)),sc);
  595.     }
  596.     }
  597.     vs         = rev(vs);            /* Put declaration lists back in    */
  598.     fs         = rev(fs);            /* original order           */
  599.     fst(e)   = pair(vs,fs);           /* Store declaration lists       */
  600.     map2Over(pmcVarDef,co,sc,vs);      /* Translate variable definitions   */
  601.     map2Proc(pmcFunDef,co,sc,fs);      /* Translate function definitions   */
  602.     snd(e)   = pmcTerm(co,sc,snd(e));  /* Translate LETREC body        */
  603.     freeFuns = diffList(freeFuns,fs);  /* Delete any `freeFuns' bound in fs*/
  604. }
  605.  
  606. static Cell local pmcVarDef(co,sc,vd)  /* apply pattern matching compiler  */
  607. Int  co;                   /* to variable definition       */
  608. List sc;
  609. List vd; {                   /* vd :: [ ([], rhs) ]           */
  610.     Cell d = snd(hd(vd));
  611.     if (nonNull(tl(vd)) && canFail(d))
  612.     return ap(FATBAR,pair(pmcTerm(co,sc,d),
  613.                   pmcVarDef(co,sc,tl(vd))));
  614.     return pmcTerm(co,sc,d);
  615. }
  616.  
  617. static Void local pmcFunDef(co,sc,fd)  /* apply pattern matching compiler  */
  618. Int    co;                   /* to function definition       */
  619. List   sc;
  620. Triple fd; {                   /* fd :: (Var, Arity, [Alt])       */
  621.     Offset saveFreeBegin = freeBegin;
  622.     List   saveFreeVars  = freeVars;
  623.     List   saveFreeFuns  = freeFuns;
  624.     Int    arity     = intOf(snd3(fd));
  625.     Cell   temp      = thd3(fd);
  626.     Cell   xs;
  627.  
  628.     map1Over(mkSwitch,sc,temp);
  629.  
  630.     freeBegin = mkOffset(co);
  631.     freeVars  = NIL;
  632.     freeFuns  = NIL;
  633.     temp      = match(co+arity,temp,addOffsets(co+arity,co+1,NIL));
  634.     thd3(fd)  = triple(freeVars,freeFuns,temp);
  635.  
  636.     for (xs=freeVars; nonNull(xs); xs=tl(xs))
  637.     if (hd(xs)<=saveFreeBegin && !cellIsMember(hd(xs),saveFreeVars))
  638.         saveFreeVars = cons(hd(xs),saveFreeVars);
  639.  
  640.     for (xs=freeFuns; nonNull(xs); xs=tl(xs))
  641.     if (!cellIsMember(hd(xs),saveFreeFuns))
  642.         saveFreeFuns = cons(hd(xs),saveFreeFuns);
  643.  
  644.     freeBegin = saveFreeBegin;
  645.     freeVars  = saveFreeVars;
  646.     freeFuns  = saveFreeFuns;
  647. }
  648.  
  649. /* --------------------------------------------------------------------------
  650.  * Main part of pattern matching compiler: convert lists of Alt to case
  651.  * construct:
  652.  *
  653.  * At each stage, each branch is represented by an element of type:
  654.  *    Switch ::= ([Pat],Scope,Rhs)
  655.  * which indicates that, if we can succeed in matching the given list of
  656.  * patterns, then the result will be the indicated Rhs.  The Scope component
  657.  * has type:
  658.  *    Scope  ::= [(Var,Expr)]
  659.  * and provides a mapping from variable names to offsets used in the matching
  660.  * process.
  661.  *
  662.  * ------------------------------------------------------------------------*/
  663.  
  664. #define switchPats(s)          fst3(s)
  665. #define switchSyms(s)          snd3(s)
  666. #define switchRhs(s)          thd3(s)
  667. #define addSym(v,o,s)          switchSyms(s) = cons(pair(v,o),switchSyms(s))
  668. #define matchMore(sw,c,co,us) nonNull(sw)?ap(FATBAR,pair(c,match(co,sw,us))):c
  669.  
  670.                        /* There are three kinds of case:   */
  671. #define CONDISCR          0        /* Constructor               */
  672. #define INTDISCR          1        /* Integer (integer const/n+k)       */
  673. #define VARDISCR          2        /* variable (or wildcard)       */
  674.  
  675. #define isConPat(discr)       (discrKind(discr)==CONDISCR)
  676. #define isVarPat(discr)       (discrKind(discr)==VARDISCR)
  677. #define isIntPat(discr)       (discrKind(discr)==INTDISCR)
  678.  
  679. static Cell local match(co,sws,us)     /* produce case statement to select */
  680. Int  co;                   /* between switches in sw, matching */
  681. List sws;                   /* pats against values at offsets   */
  682. List us; {                   /* given by us.    co is the current  */
  683.     if (nonNull(us)) {               /* offset at which new values are   */
  684.     Cell discr;               /* saved                */
  685.  
  686.     map1Proc(tidyHdPat,hd(us),sws);
  687.     switch (discrKind(discr=hdDiscr(sws))) {
  688.         case CONDISCR : return matchCon(co,sws,us,discr);
  689.         case INTDISCR : return matchInt(co,sws,us,discr);
  690.         case VARDISCR : return matchVar(co,sws,us,discr);
  691.     }
  692.     }
  693.     return joinSw(co,sws);
  694. }
  695.  
  696. static Void local tidyHdPat(u,s)       /* tidy head of pat list in a switch*/
  697. Offset u;                   /* (Principally eliminating @ pats) */
  698. Cell   s; {
  699.     Cell p = hd(switchPats(s));
  700.  
  701. thp:switch (whatIs(p)) {
  702.     case ASPAT   : addSym(fst(snd(p)),u,s);
  703.                p = snd(snd(p));
  704.                goto thp;
  705.  
  706.     case LAZYPAT : {   Cell nv    = inventVar();
  707.                switchRhs(s) = ap(LETREC,
  708.                          pair(remPat(snd(p),nv,NIL),
  709.                           switchRhs(s)));
  710.                p        = nv;
  711.                }
  712.                break;
  713.  
  714.     case FINLIST : p = mkConsList(snd(p));
  715.                break;
  716.  
  717.     case STRCELL : {   Text t = textOf(p);
  718.                Int  c;
  719.                p = NIL;
  720.                while ((c=textToStr(t++)[0])!='\0') {
  721.                    if (c=='\\' && (c=textToStr(t++)[0])!='\\')
  722.                    c = 0;
  723.                    p = ap(consChar(c),p);
  724.                }
  725.                p = revOnto(p,nameNil);
  726.                }
  727.                break;
  728.  
  729.     }
  730.     hd(switchPats(s)) = p;
  731. }
  732.  
  733. static Cell local hdDiscr(sws)           /* get discriminant of head pattern */
  734. List sws; {                   /* in first branch of a [Switch].   */
  735.     return getHead(hd(fst3(hd(sws))));
  736. }
  737.  
  738. static Int local discrKind(e)           /* find kind of discriminant       */
  739. Cell e; {
  740.     switch (whatIs(e)) {
  741.     case NAME      :
  742.     case TUPLE     :
  743.     case UNIT      :
  744.     case STRCELL   : /* shouldn't be here? */
  745.     case CHARCELL  : return CONDISCR;
  746.  
  747.     case INTCELL   :
  748.     case ADDPAT    :
  749.     case MULPAT    : return INTDISCR;
  750.  
  751.     case VARIDCELL :
  752.     case VAROPCELL :
  753.     case DICTVAR   :
  754.     case WILDCARD  : return VARDISCR;
  755.     }
  756.     internal("discrKind");
  757.     return 0;/*NOTREACHED*/
  758. }
  759.  
  760. Int discrArity(e)               /* find arity of discriminant       */
  761. Cell e; {
  762.     switch (whatIs(e)) {
  763.     case NAME      : return name(e).arity;
  764.  
  765.     case TUPLE     : return tupleOf(e);
  766.  
  767.     case UNIT      :
  768.     case STRCELL   : /* shouldn't be here? */
  769.         case FLOATCELL :
  770.     case CHARCELL  :
  771.     case INTCELL   : return 0;
  772.  
  773.     case ADDPAT    :
  774.     case MULPAT    :
  775.     case VARIDCELL :
  776.     case VAROPCELL :
  777.     case DICTVAR   :
  778.     case WILDCARD  : return 1;
  779.     }
  780.     internal("discrArity");
  781.     return 0;/*NOTREACHED*/
  782. }
  783.  
  784. /* --------------------------------------------------------------------------
  785.  * Match on variables:
  786.  * ------------------------------------------------------------------------*/
  787.  
  788. static Cell local matchVar(co,sws,us,discr)/* matching against a variable  */
  789. Int  co;                   /* does not trigger any evaluation, */
  790. List sws;                   /* but can extend the scope with a  */
  791. List us;                   /* new binding               */
  792. Cell discr; {
  793.     List varsw = NIL;
  794.     Cell s;
  795.  
  796.     do {
  797.     s = hd(sws);
  798.     if (discr!=WILDCARD)
  799.         addSym(discr,hd(us),s);
  800.     switchPats(s) = tl(switchPats(s));
  801.     varsw          = cons(s,varsw);
  802.     sws          = tl(sws);
  803.     } while (nonNull(sws) && isVarPat(discr=hdDiscr(sws)));
  804.  
  805.     s = match(co,rev(varsw),tl(us));
  806.     return matchMore(sws,s,co,us);
  807. }
  808.  
  809. /* --------------------------------------------------------------------------
  810.  * Match on constructors:
  811.  * ------------------------------------------------------------------------*/
  812.  
  813. static Cell local matchCon(co,sws,us,discr) /* matching against constructor*/
  814. Int  co;
  815. List sws;
  816. List us;
  817. Cell discr; {
  818.     List tab = NIL;               /* build table of (discr, [Switch]) */
  819.     Cell s;
  820.     List ps;
  821.  
  822.     do {
  823.     s          = hd(sws);
  824.     ps          = switchPats(s);
  825.     ps          = appendOnto(getArgs(hd(ps)),tl(ps));
  826.     switchPats(s) = ps;
  827.     tab          = addConTable(discr,s,tab);
  828.     sws          = tl(sws);
  829.      } while (nonNull(sws) && isConPat(discr=hdDiscr(sws)));
  830.  
  831.      s = ap(CASE,pair(hd(us),makeCases(co,rev(tab),tl(us))));
  832.      return matchMore(sws,s,co,us);
  833. }
  834.  
  835. /* type Table a b = [(a, [b])]
  836.  *
  837.  * addTable            :: a -> b -> Table a b -> Table a b
  838.  * addTable x y []         = [(x,[y])]
  839.  * addTable x y (z@(n,sws):zs)
  840.  *        | n == x     = (n,sws++[y]):zs
  841.  *        | otherwise  = (n,sws):addTable x y zs
  842.  */
  843.  
  844. static List local addConTable(x,y,tab) /* add element (x,y) to table       */
  845. Cell x, y;
  846. List tab; {
  847.     if (isNull(tab))
  848.     return singleton(pair(x,singleton(y)));
  849.     else if (fst(hd(tab))==x)
  850.     snd(hd(tab)) = appendOnto(snd(hd(tab)),singleton(y));
  851.     else
  852.     tl(tab) = addConTable(x,y,tl(tab));
  853.  
  854.     return tab;
  855. }
  856.  
  857. static Cell local makeCases(co,tab,us) /* build CASE construct for constr  */
  858. Int  co;                   /* match                */
  859. List tab;
  860. List us; {
  861.      List cases;
  862.  
  863.      for (cases=NIL; nonNull(tab); tab=tl(tab)) {
  864.      Cell n   = fst(hd(tab));
  865.      Int  co1 = co+discrArity(n);
  866.      cases      = cons(pair(n,
  867.                   match(co1,
  868.                     snd(hd(tab)),
  869.                     addOffsets(co1,co+1,us))),
  870.              cases);
  871.      }
  872.      return cases;
  873. }
  874.  
  875. /* --------------------------------------------------------------------------
  876.  * Match on integers:
  877.  * ------------------------------------------------------------------------*/
  878.  
  879. static Cell local matchInt(co,sws,us,discr)/* match against integer values */
  880. Int  co;
  881. List sws;
  882. List us;
  883. Cell discr; {
  884.     List tab    = NIL;                /* table of (discr, [Switch]) pairs */
  885.     Cell s    = hd(sws);
  886.     Cell cnkPat = NIL;            /* current MULPAT or ADDPAT       */
  887.     List ps;
  888.  
  889.     do {
  890.     if (whatIs(discr)==INTCELL) {
  891.         if (nonNull(cnkPat))
  892.         break;
  893.     }
  894.     else if (isNull(cnkPat))
  895.         cnkPat = discr;
  896.     else if (fst(cnkPat)!=fst(discr) || intValOf(cnkPat)!=intValOf(discr))
  897.         break;
  898.     else
  899.         discr  = cnkPat;
  900.  
  901.     s          = hd(sws);
  902.     ps          = switchPats(s);
  903.     ps          = appendOnto(getArgs(hd(ps)),tl(ps));
  904.     switchPats(s) = ps;
  905.     tab          = addConTable(discr,s,tab);
  906.     sws          = tl(sws);
  907.      } while (nonNull(sws) && isIntPat(discr=hdDiscr(sws)));
  908.  
  909.      s = ap(CASE,pair(hd(us),makeCases(co,rev(tab),tl(us))));
  910.      return matchMore(sws,s,co,us);
  911. }
  912.  
  913. /* --------------------------------------------------------------------------
  914.  * Miscellaneous:
  915.  * ------------------------------------------------------------------------*/
  916.  
  917. static List local addOffsets(m,n,us)   /* addOffsets m n us           */
  918. Int  m, n;                   /*  = map mkOffset [m,m-1..n] ++ us */
  919. List us; {
  920.     for (; m>=n; n++)
  921.     us = cons(mkOffset(n),us);
  922.     return us;
  923. }
  924.  
  925. static Cell local mkSwitch(sc,alt)     /* convert Alt into Switch:       */
  926. List sc;                   /* mkSwitch sc (ps,r) = (ps,sc,r)   */
  927. Pair alt; {
  928.     return triple(fst(alt),sc,snd(alt));
  929. }
  930.  
  931. static Cell local joinSw(co,sws)       /* Combine list of Switches into rhs*/
  932. Int  co;                   /* using FATBARs as necessary       */
  933. List sws; {                   /* :: [ ([], Scope, Rhs) ]       */
  934.     Cell s = hd(sws);
  935.  
  936.     if (nonNull(tl(sws)) && canFail(thd3(s)))
  937.     return ap(FATBAR,
  938.           pair(pmcTerm(co,snd3(s),thd3(s)),
  939.                joinSw(co,tl(sws))));
  940.     return pmcTerm(co,snd3(s),thd3(s));
  941. }
  942.  
  943. static Bool local canFail(rhs)           /* Determine if expression (as rhs) */
  944. Cell rhs; {                   /* might ever be able to fail       */
  945.     switch (whatIs(rhs)) {
  946.     case LETREC  : return canFail(snd(snd(rhs)));
  947.     case GUARDED : return TRUE;    /* could get more sophisticated ..? */
  948.     default      : return FALSE;
  949.     }
  950. }
  951.  
  952. /* --------------------------------------------------------------------------
  953.  * Lambda Lifter:    replace local function definitions with new global
  954.  *             functions.  Based on Johnsson's algorithm.
  955.  * ------------------------------------------------------------------------*/
  956.  
  957. static Cell local lift(co,tr,e)        /* lambda lift term           */
  958. Int  co;
  959. List tr;
  960. Cell e; {
  961.     switch (whatIs(e)) {
  962.     case GUARDED   : map2Proc(liftPair,co,tr,snd(e));
  963.              break;
  964.  
  965.     case FATBAR    : liftPair(co,tr,snd(e));
  966.              break;
  967.  
  968.     case CASE      : map2Proc(liftAlt,co,tr,snd(snd(e)));
  969.              break;
  970.  
  971.     case COND      : liftTriple(co,tr,snd(e));
  972.              break;
  973.  
  974.     case AP        : liftAp(co,tr,e);
  975.              break;
  976.  
  977.     case VAROPCELL :
  978.     case VARIDCELL :
  979.     case DICTVAR   : return liftVar(tr,e);
  980.  
  981.     case LETREC    : return liftLetrec(co,tr,e);
  982.  
  983.     case UNIT      :
  984.     case TUPLE     :
  985.     case NAME      :
  986.     case SELECT    :
  987.     case DICTCELL  :
  988.     case INTCELL   :
  989.     case FLOATCELL :
  990.     case STRCELL   :
  991.     case OFFSET    :
  992.     case CHARCELL  : break;
  993.  
  994.     default        : internal("Bad cterm");
  995.              break;
  996.     }
  997.     return e;
  998. }
  999.  
  1000. static Void local liftAp(co,tr,pr)     /* lift application           */
  1001. Int  co;
  1002. List tr;
  1003. Pair pr; {
  1004.     fst(pr) = lift(co+1,tr,fst(pr));
  1005.     snd(pr) = lift(co,tr,snd(pr));
  1006. }
  1007.  
  1008. static Void local liftPair(co,tr,pr)   /* lift pair of terms           */
  1009. Int  co;
  1010. List tr;
  1011. Pair pr; {
  1012.     fst(pr) = lift(co,tr,fst(pr));
  1013.     snd(pr) = lift(co,tr,snd(pr));
  1014. }
  1015.  
  1016. static Void local liftTriple(co,tr,e)  /* lift triple of terms           */
  1017. Int    co;
  1018. List   tr;
  1019. Triple e; {
  1020.     fst3(e) = lift(co,tr,fst3(e));
  1021.     snd3(e) = lift(co,tr,snd3(e));
  1022.     thd3(e) = lift(co,tr,thd3(e));
  1023. }
  1024.  
  1025. static Void local liftAlt(co,tr,pr)    /* lift (discr,case) pair       */
  1026. Int  co;
  1027. List tr;
  1028. Cell pr; {                   /* pr :: (discr,case)           */
  1029.     snd(pr) = lift(co+discrArity(fst(pr)), tr, snd(pr));
  1030. }
  1031.  
  1032. static Cell local liftVar(tr,e)        /* lift variable            */
  1033. List tr;
  1034. Cell e; {
  1035.     Text t = textOf(e);
  1036.  
  1037.     while (nonNull(tr) && textOf(fst(hd(tr)))!=t)
  1038.     tr = tl(tr);
  1039.     if (isNull(tr))
  1040.     internal("Local function not found");
  1041.     return snd(hd(tr));
  1042. }
  1043.  
  1044. static Cell local liftLetrec(co,tr,e)  /* lift letrec term           */
  1045. Int  co;
  1046. List tr;
  1047. Cell e; {
  1048.     List vs = fst(fst(snd(e)));
  1049.     List fs = snd(fst(snd(e)));
  1050.     List fds;
  1051.  
  1052.     co += length(vs);
  1053.     solve(fs);
  1054.  
  1055.     for (fds=fs; nonNull(fds); fds=tl(fds)) {
  1056.     Triple fundef = hd(fds);
  1057.     List   fvs    = fst3(thd3(fundef));
  1058.     Cell   n      = newName(textOf(fst3(fundef)));
  1059.     Cell   e0;
  1060.  
  1061.     for (e0=n; nonNull(fvs); fvs=tl(fvs))
  1062.         e0 = ap(e0,hd(fvs));
  1063.  
  1064.     tr         = cons(pair(fst3(fundef),e0),tr);
  1065.     fst3(fundef) = n;
  1066.     }
  1067.  
  1068.     map2Proc(liftFundef,co,tr,fs);
  1069.     if (isNull(vs))
  1070.     return lift(co,tr,snd(snd(e)));
  1071.     map2Over(lift,co,tr,vs);
  1072.     fst(snd(e)) = vs;
  1073.     snd(snd(e)) = lift(co,tr,snd(snd(e)));
  1074.     return e;
  1075. }
  1076.  
  1077. static Void local liftFundef(co,tr,fd) /* lift function definition       */
  1078. Int    co;
  1079. List   tr;
  1080. Triple fd; {
  1081.     Int arity = intOf(snd3(fd));
  1082.     newGlobalFunction(fst3(fd),              /* name       */
  1083.               arity,                 /* arity       */
  1084.               fst3(thd3(fd)),             /* free variables */
  1085.               co+arity,              /* current offset */
  1086.               lift(co+arity,tr,thd3(thd3(fd)))); /* lifted case    */
  1087. }
  1088.  
  1089. /* Each element in a list of fundefs has the form: (v,a,(fvs,ffs,rhs))
  1090.  * where fvs is a list of free variables which must be added as extra
  1091.  *         parameters to the lifted version of function v,
  1092.  *     ffs is a list of fundefs defined either in the group of definitions
  1093.  *         including v, or in some outer LETREC binding.
  1094.  *
  1095.  * In order to determine the correct value for fvs, we must include:
  1096.  * - all variables explicitly appearing in the body rhs (this much is
  1097.  *   achieved in pmcVar).
  1098.  * - all variables required for lifting those functions appearing in ffs.
  1099.  *   - If f is a fundef in an enclosing group of definitions then the
  1100.  *     correct list of variables to include with each occurrence of f will
  1101.  *     have already been calculated and stored in the fundef f.  We simply
  1102.  *     take the union of this list with fvs.
  1103.  *   - If f is a fundef in the same group of bindings as v, then we iterate
  1104.  *     to find the required solution.
  1105.  */
  1106.  
  1107. #ifdef DEBUG_CODE
  1108. static Void dumpFundefs(fs)
  1109. List fs; {
  1110.     printf("Dumping Fundefs:\n");
  1111.     for (; nonNull(fs); fs=tl(fs)) {
  1112.         Cell t   = hd(fs);
  1113.     List fvs = fst3(thd3(t));
  1114.     List ffs = snd3(thd3(t));
  1115.     printf("Var \"%s\", arity %d:\n",textToStr(textOf(fst3(t))),
  1116.                                          intOf(snd3(t)));
  1117.     printf("Free variables: ");
  1118.         printExp(stdout,fvs);
  1119.     putchar('\n');
  1120.     printf("Local functions: ");
  1121.         for (; nonNull(ffs); ffs=tl(ffs)) {
  1122.         printExp(stdout,fst3(hd(ffs)));
  1123.         printf("  ");
  1124.     }
  1125.     putchar('\n');
  1126.     }
  1127.     printf("----------------\n");
  1128. }
  1129. #endif
  1130.  
  1131. static Void local solve(fs)           /* Solve eqns for lambda-lifting    */
  1132. List fs; {                   /* of local function definitions    */
  1133.     Bool hasChanged;
  1134.     List fs0, fs1;
  1135.  
  1136.     /* initial pass distinguishes between those functions defined in fs and
  1137.      * those defined in enclosing LETREC clauses ...
  1138.      */
  1139.  
  1140.     for (fs0=fs; nonNull(fs0); fs0=tl(fs0)) {
  1141.     List fvs = fst3(thd3(hd(fs0)));
  1142.     List ffs = NIL;
  1143.  
  1144.     for (fs1=snd3(thd3(hd(fs0))); nonNull(fs1); fs1=tl(fs1)) {
  1145.         if (cellIsMember(hd(fs1),fs))     /* function in same LETREC*/
  1146.         ffs = cons(hd(fs1),ffs);
  1147.         else {                 /* enclosing letrec       */
  1148.         List fvs1 = fst3(thd3(hd(fs1)));
  1149.         for (; nonNull(fvs1); fvs1=tl(fvs1))
  1150.             if (!cellIsMember(hd(fvs1),fvs))
  1151.             fvs = cons(hd(fvs1),fvs);
  1152.         }
  1153.     }
  1154.     fst3(thd3(hd(fs0))) = fvs;
  1155.     snd3(thd3(hd(fs0))) = ffs;
  1156.     }
  1157.  
  1158.     /* now that the ffs component of each fundef in fs has been restricted
  1159.      * to a list of fundefs in fs, we iterate to add any extra free variables
  1160.      * that are needed (in effect, calculating the reflexive transitive
  1161.      * closure of the local call graph of fs).
  1162.      */
  1163.  
  1164.     do {
  1165.     hasChanged = FALSE;
  1166.     for (fs0=fs; nonNull(fs0); fs0=tl(fs0)) {
  1167.         List fvs0 = fst3(thd3(hd(fs0)));
  1168.         for (fs1=snd3(thd3(hd(fs0))); nonNull(fs1); fs1=tl(fs1))
  1169.          if (hd(fs1)!=hd(fs0)) {
  1170.              List fvs1 = fst3(thd3(hd(fs1)));
  1171.              for (; nonNull(fvs1); fvs1=tl(fvs1))
  1172.              if (!cellIsMember(hd(fvs1),fvs0)) {
  1173.                  hasChanged = TRUE;
  1174.                  fvs0    = cons(hd(fvs1),fvs0);
  1175.              }
  1176.         }
  1177.         if (hasChanged) fst3(thd3(hd(fs0))) = fvs0;
  1178.     }
  1179.     } while (hasChanged);
  1180. }
  1181.  
  1182. /* --------------------------------------------------------------------------
  1183.  * Pre-compiler: Uses output from lambda lifter to produce terms suitable
  1184.  *         for input to code generator.
  1185.  * ------------------------------------------------------------------------*/
  1186.  
  1187. static List extraVars;       /* List of additional vars to add to function   */
  1188. static Int  numExtraVars;  /* Length of extraVars               */
  1189. static Int  localOffset;   /* offset value used in original definition       */
  1190. static Int  localArity;    /* arity of function being compiled w/o extras  */
  1191.  
  1192. /* --------------------------------------------------------------------------
  1193.  * Arrangement of arguments on stack prior to call of
  1194.  *           n x_1 ... x_e y_1 ... y_a
  1195.  * where
  1196.  *    e = numExtraVars,      x_1,...,x_e are the extra params to n
  1197.  *    a = localArity of n,   y_1,...,y_a are the original params
  1198.  *
  1199.  *    offset 1       :  y_a  }                   STACKPART1
  1200.  *    ..           }
  1201.  *    offset a       :  y_1  }
  1202.  *
  1203.  *    offset 1+a   :  x_e  }                   STACKPART2
  1204.  *    ..           }
  1205.  *    offset e+a   :  x_1  }
  1206.  *
  1207.  *    offset e+a+1 :  used for temporary results ...   STACKPART3
  1208.  *    ..
  1209.  *    ..
  1210.  *
  1211.  * In the original defn for n, the offsets in STACKPART1 and STACKPART3
  1212.  * are contiguous.  To add the extra parameters we need to insert the
  1213.  * offsets in STACKPART2, adjusting offset values as necessary.
  1214.  * ------------------------------------------------------------------------*/
  1215.  
  1216. static Cell local preComp(e)           /* Adjust output from compiler to   */
  1217. Cell e; {                   /* include extra parameters       */
  1218.     switch (whatIs(e)) {
  1219.     case GUARDED   : mapOver(preCompPair,snd(e));
  1220.                  break;
  1221.  
  1222.     case LETREC    : mapOver(preComp,fst(snd(e)));
  1223.                  snd(snd(e)) = preComp(snd(snd(e)));
  1224.                  break;
  1225.  
  1226.     case COND      : return ap(COND,preCompTriple(snd(e)));
  1227.  
  1228.     case FATBAR    : return ap(FATBAR,preCompPair(snd(e)));
  1229.  
  1230.     case AP        : return preCompPair(e);
  1231.  
  1232.     case CASE      : fst(snd(e)) = preComp(fst(snd(e)));
  1233.                  mapProc(preCompCase,snd(snd(e)));
  1234.                  break;
  1235.  
  1236.     case OFFSET    : return preCompOffset(offsetOf(e));
  1237.  
  1238.     case UNIT      :
  1239.     case TUPLE     :
  1240.     case NAME      :
  1241.     case SELECT    :
  1242.     case DICTCELL  :
  1243.     case INTCELL   :
  1244.     case FLOATCELL :
  1245.     case STRCELL   :
  1246.     case CHARCELL  : break;
  1247.  
  1248.     default        : internal("preComp");
  1249.     }
  1250.     return e;
  1251. }
  1252.  
  1253. static Cell local preCompPair(e)       /* Apply preComp to pair of Exprs   */
  1254. Pair e; {
  1255.     return pair(preComp(fst(e)),
  1256.         preComp(snd(e)));
  1257. }
  1258.  
  1259. static Cell local preCompTriple(e)     /* Apply preComp to triple of Exprs */
  1260. Triple e; {
  1261.     return triple(preComp(fst3(e)),
  1262.           preComp(snd3(e)),
  1263.           preComp(thd3(e)));
  1264. }
  1265.  
  1266. static Void local preCompCase(e)       /* Apply preComp to (Discr,Expr)    */
  1267. Pair e; {
  1268.     snd(e) = preComp(snd(e));
  1269. }
  1270.  
  1271. static Cell local preCompOffset(n)     /* Determine correct offset value   */
  1272. Int n; {                   /* for local variable/function arg. */
  1273.     if (n>localOffset-localArity)
  1274.     if (n>localOffset)                     /* STACKPART3 */
  1275.         return mkOffset(n-localOffset+localArity+numExtraVars);
  1276.     else                             /* STACKPART1 */
  1277.         return mkOffset(n-localOffset+localArity);
  1278.     else {                             /* STACKPART2 */
  1279.     List fvs = extraVars;
  1280.     Int  i     = localArity+numExtraVars;
  1281.  
  1282.     for (; nonNull(fvs) && offsetOf(hd(fvs))!=n; --i)
  1283.         fvs=tl(fvs);
  1284.     return mkOffset(i);
  1285.     }
  1286. }
  1287.  
  1288. /* --------------------------------------------------------------------------
  1289.  * Main entry points to compiler:
  1290.  * ------------------------------------------------------------------------*/
  1291.  
  1292. Void compileExp() {               /* compile input expression       */
  1293.     compiler(RESET);
  1294.  
  1295.     inputExpr     = lift(0,NIL,pmcTerm(0,NIL,translate(inputExpr)));
  1296.     extraVars     = NIL;
  1297.     numExtraVars = 0;
  1298.     localOffset  = 0;
  1299.     localArity     = 0;
  1300.     inputCode     = codeGen(NIL,0,preComp(inputExpr));
  1301.     inputExpr     = NIL;
  1302. }
  1303.  
  1304. Void compileDefns() {               /* compile script definitions       */
  1305.     Target t = length(valDefns) + length(overDefns);
  1306.     Target i = 0;
  1307.  
  1308.     setGoal("Compiling",t);
  1309.     for (; nonNull(valDefns); valDefns=tl(valDefns)) {
  1310.     mapProc(compileGlobalFunction,transBinds(hd(valDefns)));
  1311.     soFar(i++);
  1312.     }
  1313.     for (; nonNull(overDefns); overDefns=tl(overDefns)) {
  1314.         compileMemberFunction(hd(overDefns));
  1315.     soFar(i++);
  1316.     }
  1317.     done();
  1318. }
  1319.  
  1320. static Void local compileGlobalFunction(bind)
  1321. Pair bind; {
  1322.     Name n     = findName(textOf(fst(bind)));
  1323.     List defs  = snd(bind);
  1324.     Int  arity = length(fst(hd(defs)));
  1325.  
  1326.     if (isNull(n))
  1327.     internal("no such name in compileGlobalFunction");
  1328.     compiler(RESET);
  1329.     map1Over(mkSwitch,NIL,defs);
  1330.     newGlobalFunction(n,
  1331.               arity,
  1332.               NIL,
  1333.               arity,
  1334.               lift(arity,
  1335.                NIL,
  1336.                match(arity,
  1337.                  defs,
  1338.                  addOffsets(arity,1,NIL))));
  1339. }
  1340.  
  1341. static Void local compileMemberFunction(n)
  1342. Name n; {
  1343.     List defs  = name(n).defn;
  1344.     Int  arity = length(fst(hd(defs)));
  1345.  
  1346.     compiler(RESET);
  1347.     mapProc(transAlt,defs);
  1348.     map1Over(mkSwitch,NIL,defs);
  1349.     newGlobalFunction(n,
  1350.               arity,
  1351.               NIL,
  1352.               arity,
  1353.               lift(arity,
  1354.                NIL,
  1355.                match(arity,
  1356.                  defs,
  1357.                  addOffsets(arity,1,NIL))));
  1358. }
  1359.  
  1360. static Void local newGlobalFunction(n,arity,fvs,co,e)
  1361. Name n;
  1362. Int  arity;
  1363. List fvs;
  1364. Int  co;
  1365. Cell e; {
  1366.     extraVars      = fvs;
  1367.     numExtraVars  = length(extraVars);
  1368.     localOffset   = co;
  1369.     localArity      = arity;
  1370.     name(n).arity = arity+numExtraVars;
  1371.     name(n).code  = codeGen(n,name(n).arity,preComp(e));
  1372.     name(n).defn  = NIL;
  1373. }
  1374.  
  1375. /* --------------------------------------------------------------------------
  1376.  * Compiler control:
  1377.  * ------------------------------------------------------------------------*/
  1378.  
  1379. Void compiler(what)
  1380. Int what; {
  1381.     switch (what) {
  1382.     case INSTALL :
  1383.     case RESET   : freeVars      = NIL;
  1384.                freeFuns      = NIL;
  1385.                freeBegin     = mkOffset(0);
  1386.                extraVars     = NIL;
  1387.                numExtraVars  = 0;
  1388.                localOffset   = 0;
  1389.                localArity    = 0;
  1390.                break;
  1391.  
  1392.     case MARK    : mark(freeVars);
  1393.                mark(freeFuns);
  1394.                mark(extraVars);
  1395.                break;
  1396.     }
  1397. }
  1398.  
  1399. /*-------------------------------------------------------------------------*/
  1400.